home *** CD-ROM | disk | FTP | other *** search
/ PC-X 1997 October / pcx14_9710.iso / swag / delphi.swg / 0229_Re: IShellLink Example.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-03-04  |  15.3 KB  |  547 lines
  1.  
  2.      This is last source code for my ShellLink component.
  3.  
  4.      //******************************************************* //*
  5.      Shell Link Component for Delphi 2.0           * //*
  6.                                       * //*   this is end version
  7.                          * //*
  8.             * //*   for new versions send e-mail,s-mail,fax           * //*
  9.        with you name and e-mail adress to >              * //*
  10.                                             * //*
  11.      voltr.radek/4600/epr@epr1.ccmail.x400.cez.cz     * //*
  12.                                          * //*    (c) 1996 Radek Voltr
  13.                             * //*             Kozeluzska 1523
  14.                * //*             Kadan 43201    CZECH Republic   Europe  *
  15.      //*             fax. 42 398 2776                        * //*
  16.      note: this version is free                     *
  17.      //*******************************************************
  18.  
  19.      unit SheLink;
  20.  
  21.      interface
  22.  
  23.      uses
  24.      Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  25.      Dialogs, Ole2;
  26.  
  27.      const
  28.      SLR_NO_UI           = _0001;
  29.      SLR_ANY_MATCH       = _0002;
  30.      SLR_UPDATE          = _0004;
  31.  
  32.      SLGP_SHORTPATH      = _0001;
  33.      SLGP_UNCPRIORITY    = _0002;
  34.  
  35.      CLSID_ShellLink:    TCLSID = (D1:_00021401; D2:_0; D3:_0;
  36.      D4:(_C0,_0,_0,_0,_0,_0,_0,_46));
  37.      IID_IShellLink:      TCLSID = (D1:_000214EE; D2:_0; D3:_0;
  38.      D4:(_C0,_0,_0,_0,_0,_0,_0,_46));
  39.  
  40.      type
  41.      PShellLink = ^IShellLink;
  42.      IShellLink = class(IUnknown)
  43.      public
  44.      Function GetPath(pszFile:PChar;cchMaxPath:Integer;var
  45.      pfd:TWin32FindData;fFlags:DWord):HResult; virtual; stdcall; abstract;
  46.      Function GetIDList(ppidl:pointer) :HResult; virtual; stdcall;
  47.      abstract; Function SetIDList(const pidl:pointer) :HResult; virtual;
  48.      stdcall; abstract; Function
  49.      GetDescription(pszName:PChar;cchMaxName:Integer) :HResult; virtual;
  50.      stdcall; abstract;
  51.      Function SetDescription(Const pszName:PChar) :HResult; virtual;
  52.      stdcall;
  53.      abstract;
  54.      Function GetWorkingDirectory(pszDir:PChar;cchMaxPath:Integer)
  55.      :HResult;
  56.      virtual; stdcall; abstract;
  57.      Function SetWorkingDirectory(const pszDir:PChar) :HResult; virtual;
  58.      stdcall;
  59.      abstract;
  60.      Function GetArguments(pszDir:PChar;cchMaxPath:Integer) :HResult;
  61.      virtual;
  62.      stdcall; abstract;
  63.      Function SetArguments(const pszArgs:PChar) :HResult; virtual; stdcall;
  64.      abstract;
  65.      Function GetHotkey(pwHotkey:PWord) :HResult; virtual; stdcall;
  66.      abstract; Function SetHotkey(wHotkey:Word) :HResult; virtual; stdcall;
  67.      abstract; Function GetShowCmd(piShowCmd:PInteger) :HResult; virtual;
  68.      stdcall;
  69.      abstract;
  70.      Function SetShowCmd(iShowCmd:Integer) :HResult; virtual; stdcall;
  71.      abstract; Function
  72.      GetIconLocation(pszIconPath:PChar;cchIconPath:Integer;piIcon:PInteger)
  73.      :HResult; virtual; stdcall; abstract;
  74.      Function SetIconLocation(const pszIconPath:PChar;iIcon:Integer)
  75.      :HResult;
  76.      virtual; stdcall; abstract;
  77.      Function SetRelativePath(const pszPathRel:PChar;dwReserved:Dword)
  78.      :HResult;
  79.      virtual; stdcall; abstract;
  80.      Function Resolve(wnd:hWnd;fFlags:Dword) :HResult; virtual; stdcall;
  81.      abstract;
  82.      Function SetPath(Const pszFile:PChar) :HResult; virtual; stdcall;
  83.      abstract;
  84.      end;
  85.  
  86.  
  87.      type
  88.      TShellLink = class(TComponent)
  89.      private
  90.      { Private declarations }
  91.      procedure fSetSelfPath(const S:String); protected
  92.      { Protected declarations }
  93.      fUpdate:Boolean;
  94.      fPath,
  95.      fTarget,
  96.      fWorkingDir,
  97.      fDescription,
  98.      fArguments,
  99.      fIconLocation:String;
  100.      fIconNumber,
  101.      fShowCmd,
  102.      fHotKey:Word;
  103.      public
  104.      { Public declarations }
  105.      //    constructor Create;
  106.      procedure SetSelfPath(const S:String); procedure SetUpdate(const
  107.      S:Boolean); procedure CreateNew(const Path,Target:String); procedure
  108.      SaveToFile(const Path:String);
  109.      published
  110.      { Published declarations }
  111.      property Path:String read fPath write fSetSelfPath; property
  112.      Target:String read fTarget write fTarget;
  113.      property WorkingDir:String read fWorkingDir write fWorkingDir;
  114.      property Description:String read fDescription write fDescription;
  115.      property Arguments:String read fArguments write fArguments;
  116.      property IconLocation:String read fIconLocation write fIconLocation;
  117.      property HotKey:word read fHotKey write fHotKey;
  118.      property ShowCmd:word read fShowCmd write fShowCmd;
  119.      property IconNumber:word read fIconNumber write fIconNumber; property
  120.      Update:boolean read fUpdate write SetUpdate;
  121.      end;
  122.  
  123.      procedure Register;
  124.  
  125.      implementation
  126.  
  127.      procedure Register;
  128.      begin
  129.      RegisterComponents('Win95', [TShellLink]); end;
  130.  
  131.  
  132.      procedure TShellLink.SetSelfPath(const S:String); var X3:PChar;
  133.      hresx:HResult;
  134.      Psl:IShellLink;
  135.      Ppf:IPersistFile;
  136.      Saver:Array [0..Max_Path] of WideChar; X1:Array [0..255] Of Char;
  137.      Data:TWin32FindData;I,Y:INteger;W:Word;
  138.      begin
  139.      hresx:=CoCreateInstance(CLSID_ShellLink,nil,CLSCTX_INPROC_SERVER,IID_I
  140.      ShellLink, psl);
  141.      If hresx<>0 then Exit;
  142.      hresx:=psl.QueryInterface(IID_IPersistFile,ppf); If hresx<>0 then
  143.      Exit;
  144.      X3:=StrAlloc(255);
  145.      StrPCopy(X3,S);
  146.      MultiByteToWideChar(CP_ACP,0,X3,-1,Saver,Max_Path);
  147.      hresx:=ppf.Load(Saver,STGM_READ);
  148.      If hresx<>0 then
  149.      begin
  150.      MessageBox(0,'File not found (or not link)','!! Error !!',mb_IconHand
  151.      or mb_ok); Exit;
  152.      end;
  153.      hresx:=psl.Resolve(0,SLR_ANY_MATCH); If hresx<>0 then Exit; hresx:=
  154.      psl.GetWorkingDirectory(@X1,MAX_PATH ); If hresx<>0 then begin
  155.      MessageBox(0,'Error in get WD','!! Error !!',mb_IconHand or mb_ok);
  156.      Exit;
  157.      end;
  158.      fWorkingDir:=StrPas(@X1);
  159.  
  160.      hresx:= psl.GetPath( @X1,MAX_PATH,Data,SLGP_UNCPRIORITY); If hresx<>0
  161.      then
  162.      begin
  163.      MessageBox(0,'Error in get GP','!! Error !!',mb_IconHand or mb_ok);
  164.      Exit;
  165.      end;
  166.      fTarget:=StrPas(@X1);
  167.  
  168.      hresx:=psl.GetIconLocation(@X1,MAX_PATH,@I); If hresx<>0 then begin
  169.      MessageBox(0,'Error in get IL','!! Error !!',mb_IconHand or mb_ok);
  170.      Exit;
  171.      end;
  172.      fIconLocation:=StrPas(@X1);
  173.      fIconNumber:=I;
  174.  
  175.      hresx:= psl.GetDescription(@X1,MAX_PATH ); If hresx<>0 then begin
  176.      MessageBox(0,'Error in get DE','!! Error !!',mb_IconHand or mb_ok);
  177.      Exit;
  178.      end;
  179.      fDescription:=StrPas(@X1);
  180.  
  181.      Y:=0;
  182.      hresx:= psl.GetShowCmd(@Y);
  183.      If hresx<>0 then
  184.      begin
  185.      MessageBox(0,'Error in get SC','!! Error !!',mb_IconHand or mb_ok);
  186.      Exit;
  187.      end;
  188.      fShowCmd:=Y;
  189.  
  190.      W:=0;
  191.      hresx:= psl.GetHotKey(@W);
  192.      If hresx<>0 then
  193.      begin
  194.      MessageBox(0,'Error in get HK','!! Error !!',mb_IconHand or mb_ok);
  195.      Exit;
  196.      end;
  197.      fHotKey:=W;
  198.  
  199.      hresx:= psl.GetArguments(@X1,MAX_PATH ); If hresx<>0 then begin
  200.      MessageBox(0,'Error in get AR','!! Error !!',mb_IconHand or mb_ok);
  201.      Exit;
  202.      end;
  203.      fArguments:=StrPas(@X1);
  204.  
  205.      ppf.release;
  206.      psl.release;
  207.      StrDispose(X3);
  208.      fPath:=S;
  209.      end;
  210.  
  211.      procedure TShellLink.SetUpdate(const S:Boolean); begin
  212.      SetSelfPath(fPath);
  213.      fUpdate:=True;
  214.      end;
  215.  
  216.      procedure TShellLink.fSetSelfPath(const S:String); begin
  217.      SetSelfPath(S);
  218.      end;
  219.  
  220.      procedure TShellLink.CreateNew(const Path,Target:String); var
  221.      X1,X3:PChar;S,S2,S3:String[255];
  222.      hresx:HResult;
  223.      Psl:IShellLink;
  224.      Ppf:IPersistFile;
  225.      Saver:Array [0..Max_Path] of WideChar; begin
  226.      hresx:=0;
  227.      hresx:=CoCreateInstance(CLSID_ShellLink,nil,CLSCTX_INPROC_SERVER,IID_I
  228.      ShellLink, psl);
  229.      If hresx<>0 then
  230.      begin
  231.      MessageBox(0,'Error in create instance','!! Error !!',mb_IconHand or
  232.      mb_ok); Exit;
  233.      end;
  234.  
  235.      X1:=StrAlloc(255);
  236.      X3:=StrAlloc(255);
  237.      try
  238.      StrPCopy(X1,Target);
  239.      hresx:=psl.SetPath(X1);
  240.      if hresx<>0 then
  241.      begin
  242.      MessageBox(0,'Error in set path','!! Error !!',mb_IconHand or mb_ok);
  243.      Exit;
  244.      end;
  245.  
  246.      hresx:=psl.QueryInterface(IID_IPersistFile,ppf); if hresx<>0 then
  247.      begin
  248.      MessageBox(0,'Error in query interface','!! Error !!',mb_IconHand or
  249.      mb_ok); Exit;
  250.      end;
  251.  
  252.      StrPCopy(X3,Path);
  253.  
  254.      MultiByteToWideChar(CP_ACP,0,X3,-1,Saver,Max_Path);
  255.  
  256.      hresx:=ppf.Save(Saver,True);
  257.      If hresx=0 then
  258.      begin
  259.      MessageBox(0,'Error in save','!! Error !!',mb_IconHand or mb_ok);
  260.      Exit;
  261.      end;
  262.  
  263.      finally
  264.      ppf.release;
  265.      psl.release;
  266.      StrDispose(X1);
  267.      StrDispose(X3);
  268.      end;
  269.      End;
  270.  
  271.      procedure TShellLink.SaveToFile(const Path:String); var
  272.      X1,X3:PChar;S,S2,S3:String[255];
  273.      hresx:HResult;
  274.      Psl:IShellLink;
  275.      Ppf:IPersistFile;
  276.      Saver:Array [0..Max_Path] of WideChar; begin
  277.      hresx:=0;
  278.      hresx:=CoCreateInstance(CLSID_ShellLink,nil,CLSCTX_INPROC_SERVER,IID_I
  279.      ShellLink, psl);
  280.      If hresx<>0 then
  281.      begin
  282.      MessageBox(0,'Error in create instance','!! Error !!',mb_IconHand or
  283.      mb_ok); Exit;
  284.      end;
  285.  
  286.      X1:=StrAlloc(255);
  287.      X3:=StrAlloc(255);
  288.      try
  289.      StrPCopy(X1,fTarget);
  290.      hresx:=psl.SetPath(PChar(fTarget));
  291.      If hresx<>0 then
  292.      begin
  293.      MessageBox(0,'Error in set path','!! Error !!',mb_IconHand or mb_ok);
  294.      Exit;
  295.      end;
  296.  
  297.      StrPCopy(X1,fDescription);
  298.      hresx:=psl.SetDescription(X1);
  299.      hresx:=psl.SetWorkingDirectory(PChar(fWorkingDir));
  300.      hresx:=psl.SetArguments(PChar(fArguments));
  301.      hresx:=psl.SetHotKey(fHotKey);
  302.      hresx:=psl.SetShowCmd(fShowCmd);
  303.      hresx:=psl.SetIconLocation(PChar(fIconLocation),IconNumber);
  304.  
  305.  
  306.      hresx:=psl.QueryInterface(IID_IPersistFile,ppf); If hresx<>0 then
  307.      begin
  308.      MessageBox(0,'Error in query interface','!! Error !!',mb_IconHand or
  309.      mb_ok); Exit;
  310.      end;
  311.  
  312.      StrPCopy(X3,Path);
  313.  
  314.      MultiByteToWideChar(CP_ACP,0,X3,-1,Saver,Max_Path);
  315.  
  316.      hresx:=ppf.Save(Saver,True);
  317.  
  318.      If hresx<>0 then
  319.      begin
  320.      MessageBox(0,'Error in save','!! Error !!',mb_IconHand or mb_ok);
  321.      Exit;
  322.      end;
  323.      ppf.release;
  324.      finally
  325.      psl.release;
  326.      StrDispose(X1);
  327.      StrDispose(X3);
  328.      end;
  329.      End;
  330.  
  331.  
  332.      begin
  333.      end.
  334.  
  335.  
  336.      *******************************************************
  337.      and this is sample code for create link and retrieve information from
  338.      link
  339.      *******************************************************
  340.  
  341.      unit test1;
  342.  
  343.      interface
  344.  
  345.      uses
  346.      Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  347.      Dialogs, SheLink, StdCtrls,Ole2;
  348.  
  349.      type
  350.      TForm1 = class(TForm)
  351.      GroupBox1: TGroupBox;
  352.      Memo1: TMemo;
  353.      Button1: TButton;
  354.      Link: TShellLink;
  355.      Open1: TOpenDialog;
  356.      GroupBox2: TGroupBox;
  357.      Edit1: TEdit;
  358.      Label1: TLabel;
  359.      Button2: TButton;
  360.      Label2: TLabel;
  361.      Edit2: TEdit;
  362.      Button3: TButton;
  363.      Open2: TOpenDialog;
  364.      Save: TSaveDialog;
  365.      Button4: TButton;
  366.      procedure Button1Click(Sender: TObject); procedure
  367.      Button2Click(Sender: TObject); procedure Button3Click(Sender:
  368.      TObject); procedure Button4Click(Sender: TObject); procedure
  369.      FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject);
  370.      private
  371.      { Private declarations }
  372.      public
  373.      { Public declarations }
  374.      end;
  375.  
  376.      var
  377.      Form1: TForm1;
  378.  
  379.      implementation
  380.  
  381.      {_R *.DFM}
  382.  
  383.      procedure TForm1.Button1Click(Sender: TObject); begin If Not
  384.      Open1.Execute then Exit;
  385.      Link.SetSelfPath(Open1.FileName);
  386.      Memo1.Lines.Add('Arguments :'+Link.Arguments);
  387.      Memo1.Lines.Add('Description :'+Link.Description);
  388.      Memo1.Lines.Add('Hotkey :'+IntToStr(Link.Hotkey));
  389.      Memo1.Lines.Add('Target :'+Link.Target); Memo1.Lines.Add('WorkingDir
  390.      :'+Link.WorkingDir); end;
  391.  
  392.      procedure TForm1.Button2Click(Sender: TObject); begin If Open2.Execute
  393.      then Edit1.Text:=Open2.FileName; end;
  394.  
  395.      procedure TForm1.Button3Click(Sender: TObject); begin If Save.Execute
  396.      then Edit2.Text:=Save.FileName; end;
  397.  
  398.      procedure TForm1.Button4Click(Sender: TObject); begin
  399.      Link.CreateNew(Edit2.Text,Edit1.Text); end;
  400.  
  401.      procedure TForm1.FormCreate(Sender: TObject); begin CoInitialize(nil);
  402.                        // required for Shell link end;
  403.  
  404.      procedure TForm1.FormDestroy(Sender: TObject); begin
  405.      CoUninitialize;                      // required for Shell link end;
  406.  
  407.      end.
  408.  
  409.      a tadu je k tomu form
  410.  
  411.      object Form1: TForm1
  412.      Left = 223
  413.      Top = 107
  414.      Width = 435
  415.      Height = 300
  416.      Caption = 'Shell Link Demo'
  417.      Font.Color = clWindowText
  418.      Font.Height = -11
  419.      Font.Name = 'MS Sans Serif'
  420.      Font.Style = []
  421.      OnCreate = FormCreate
  422.      OnDestroy = FormDestroy
  423.      PixelsPerInch = 96
  424.      TextHeight = 13
  425.      object GroupBox1: TGroupBox
  426.      Left = 4
  427.      Top = 4
  428.      Width = 419
  429.      Height = 147
  430.      Caption = ' Get info from shell link ' TabOrder = 0 object Memo1:
  431.      TMemo
  432.      Left = 6
  433.      Top = 18
  434.      Width = 407
  435.      Height = 101
  436.      TabOrder = 0
  437.      end
  438.      object Button1: TButton
  439.      Left = 6
  440.      Top = 120
  441.      Width = 407
  442.      Height = 25
  443.      Caption = 'Get info'
  444.      TabOrder = 1
  445.      OnClick = Button1Click
  446.      end
  447.      end
  448.      object GroupBox2: TGroupBox
  449.      Left = 4
  450.      Top = 154
  451.      Width = 419
  452.      Height = 117
  453.      Caption = ' Create new link '
  454.      TabOrder = 1
  455.      object Label1: TLabel
  456.      Left = 12
  457.      Top = 14
  458.      Width = 34
  459.      Height = 13
  460.      Caption = 'Target '
  461.      end
  462.      object Label2: TLabel
  463.      Left = 12
  464.      Top = 52
  465.      Width = 82
  466.      Height = 13
  467.      Caption = 'Name of new link'
  468.      end
  469.      object Edit1: TEdit
  470.      Left = 10
  471.      Top = 30
  472.      Width = 321
  473.      Height = 21
  474.      TabOrder = 0
  475.      Text = 'C:\Autoexec.bat'
  476.      end
  477.      object Button2: TButton
  478.      Left = 338
  479.      Top = 26
  480.      Width = 75
  481.      Height = 25
  482.      Caption = 'Browse'
  483.      TabOrder = 1
  484.      OnClick = Button2Click
  485.      end
  486.      object Edit2: TEdit
  487.      Left = 10
  488.      Top = 68
  489.      Width = 321
  490.      Height = 21
  491.      TabOrder = 2
  492.      Text = 'C:\this is shortcut to Autoexec.bat.lnk' end
  493.      object Button3: TButton
  494.      Left = 338
  495.      Top = 64
  496.      Width = 75
  497.      Height = 25
  498.      Caption = 'Browse'
  499.      TabOrder = 3
  500.      OnClick = Button3Click
  501.      end
  502.      object Button4: TButton
  503.      Left = 10
  504.      Top = 90
  505.      Width = 405
  506.      Height = 25
  507.      Caption = 'Create new link (shortcut)' TabOrder = 4 OnClick =
  508.      Button4Click
  509.      end
  510.      end
  511.      object Link: TShellLink
  512.      HotKey = 0
  513.      ShowCmd = 0
  514.      IconNumber = 0
  515.      Update = True
  516.      Left = 378
  517.      Top = 24
  518.      end
  519.      object Open1: TOpenDialog
  520.      FileEditStyle = fsEdit
  521.      Filter = 'Link files|*.lnk|Pif files|*.pif' Options =
  522.      [ofNoDereferenceLinks]
  523.      Left = 378
  524.      Top = 56
  525.      end
  526.      object Open2: TOpenDialog
  527.      FileEditStyle = fsEdit
  528.      Filter = 'All files|*.*'
  529.      Left = 302
  530.      Top = 170
  531.      end
  532.      object Save: TSaveDialog
  533.      DefaultExt = '*.lnk'
  534.      FileEditStyle = fsEdit
  535.      Filter = '*.lnk|*.lnk'
  536.      Left = 302
  537.      Top = 216
  538.      end
  539.      end
  540.  
  541.  
  542.  
  543.      Bye Radek Voltr
  544.  
  545.      voltrr1@epr1.ccmail.x400.cez.cz
  546.  
  547.